COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 MACLSP FORK PACKAGE
C00007 00003	(defun writefork (filnam fork# expr)
C00015 00004	(LAP FORKME SUBR)
C00019 00005	(ENTRY MSG SUBR)
C00022 00006	(ENTRY GMSG SUBR)
C00028 00007	(ENTRY GETMYJOB SUBR)
C00029 ENDMK
C⊗;
;;; MACLSP FORK PACKAGE
;;; Written by Jorge Phillips (6/22/77 last modification)

(declare (*lexpr  fork sndmsg)) 
(declare (setsyntax 54 500500 54))

(defun createfork (dmpfil uplowfile)
;;; dmpfil is the dumpfile to be run as a separate process. It is a 4 list
;;; uplowfile is a 2-list that specifies communication file TO lower fork in the
;;; CRUNIT directory of the luser. returns a dotted pair (lowerfork# . comfile)
;;; where comfile is the lower-upper communication file
;;; startup protocol
;;;	fork 		------>  starts
;;;     snd job#	------>  wait for job#
;;;	wait OK		<------  send OK
;;;     snd file	------>  wait for file
;;;	wait file	<------  send file
;;;		HANDSHAKE COMPLETE
(prog (lowfrk#)
      (and (not (equal (length dmpfil) 4))
	   (print '(need complete dmp pathname))
	   (break createfork t))
      (setq lowfrk# (fork (car dmpfil)(cadr dmpfil)(caddr dmpfil)(cadddr dmpfil)))
      (or lowfrk# (break '|Bletch!!! No fork created.| T))
      (return (synchfork lowfrk# uplowfile))))
      
(defun synchfork (fork# file)
;;; sets up synch protocol with startfork. returns dotted pair as in createfork
;     (sendjob fork#)
      (waitmsg 'OK fork#)
      (sndfilmsg fork# file (getmyjob))
      (cons fork# (getfilmsg (car fork#))))

(defun fork l	
;;; fork is a lexpr that takes 4 atomic args, fil ext p pn, that should
;;; specify a dmp file to be run as a separate fork. It returns the job number
;;; of the created fork as a fixnum. Notice that fork receives dmp file in 6bit
;;; returns (createdfork# . ourjob#)
(prog (crppn fil ext p pn)
      (and (or (> l 4) (< l 1)) 
	   (print '(Too many or few args in FORK))(break fork t))
      (setq crppn (crunit))
      (and (< l 4) (setq pn (car (pnget (cadadr crppn) 6)))	;sixbit pn
	   (go a))
      (setq pn (car (pnget (arg 4) 6)))
a     (and (< l 3) (setq p (car (pnget (caadr crppn) 6)))	;sixbit p
	   (go a1))
      (setq p (car (pnget (arg 3) 6)))
a1    (and (< l 2) (setq ext (car (pnget 'dmp 6)))			;def. ext = DMP
	   (go a2))
      (setq ext (car (pnget (arg 2) 6)))
a2    (setq fil (car (pnget (arg 1) 6)))
      (return (forkme fil ext (mergeppn p pn)))))

(defun startfork (lowupfil)
;;; lowupfil is a 2-list representing the file that will be used for 
;;; communication from the lower to the upper fork. returns the a dotted
;;; pair of the form (upperfork# . filnam)
;;; the first thing a child fork should do is call this routine
(prog (upfork# uplofil)
      (uclose)
      (gc)(setq ↑T t)
      (setq upfork# (fork-suspend))		;gets job # of parent fork
      (sndmsg upfork# 'OK (getmyjob))		;synch
      (setq uplofil (getfilmsg upfork#))	;get up-low file name
      (sndfilmsg upfork# lowupfil (getmyjob))		;file message
      (return (cons upfork# uplofil))))

(defun getjob nil
;;; getjob waits for a message of type JOB from anybody. Presumably this is
;;; the parent of this fork. Notice that waitmsg returns (JOB job#)
     (cadr (waitmsg 'JOB nil)))


(defun sendjob (fork#)
;;; sends job# of this fork to fork fork#
     (sndmsg fork# 'JOB (getmyjob)))
(defun writefork (filnam fork# expr)
;;; writes on file FILNAM s-expr EXPR and notifies fork FORK#
;;; should not be used for value
    (uwrite)          				;open file for writing
    (ioc r)(ioc w)
    (print expr)
    (ioc v)					;restore printout to tty
    (apply 'ufile (list (car filnam) 
		        (or (cadr filnam) 'FRK)))	;close it
    (sndmsg fork# 'READ (getmyjob))	 		;notify fork to read
)

(defun readfork (filnam fork#)
;;; reads an s-expr from the file filnam (a communication file), waiting
;;; for a notification from fork# to go ahead
   (waitmsg 'READ fork#)		       ;wait till read message comes
   (apply 'uread filnam)		       ;start reading from file
   (ioc q)				       ;start
   (prog2 nil (read) (uclose)))		       ;get s-expr

(defun checkfork (filnam fork#)
;;; checks for an s-expr from the file filnam (a communication file), if there is
;;; a notification from fork# it returns the expression, else nil
   (cond ((chkmsg 'READ fork#)		       ;wait till read message comes
   	  (apply 'uread filnam)		       ;start reading from file
   	  (ioc q)			       ;start
       	  (prog2 nil (read) (uclose)))))       ;get s-expr

;;;
;;; the following are interface routines with lap code
;;;

(defun sndfilmsg (forknum file from)
;;; send intercommunication file name to fork forknum. file should be a 2-list
;;; of form (filnam ext) in the crunit directory.
;;; from is job# of this job. should have been acquired by mail or by forking
   (or (fixp from) (error '|Foo luser!! Bad fork: | from))
   (and (not (equal (length file) 2))
	(print '(need full pathname!))
	(break sndfilmsg t))
   (sndmsg  forknum 'FIL from file))

(defun sndmsg mess
;;; lexpr that assembles message in mail buffer and ships it out to fork
;;; must have at least 3 args, the first one an integer (forknum), the
;;; second one a message type. The third one is the caller's job#. The 
;;; fourht one is a list of atoms (of less  than 5 chars each, restriction to dissapear)
;;; which is converted into a list of ascii fixnum equivalents and assembled
;;; consecutively as the message. system limits the size of this list to
;;; at most 30 words (the first two words carry msgtyp and jobnum). Notice that
;;; only the first 5 chars are used of each pname. Returns NIL if
;;; the message could not be sent due to full mailbox, NOJOB if the fork doesnt
;;; exist and T otherwise
   (and (or (< mess 3)(> mess 4))
	(princ '|Wrong # args!|)
	(break sndmsg t))
  (do nil
   ((msg (arg 1)
	(and (arg 2)(car (pnget (arg 2) 7)))	;nil if no type
	(and (= mess 4)(mapcar (function (lambda (w)(car (pnget w 7))))
			       (arg 4)))
	(arg 3) ) )))

(defun waitmsg (type fork#)
(prog (w)
   a	(setq w (chkmsg type fork#)) ;wait and check incoming mail
	(and w (return w))	     ;chkmsg returned message
	(go a)))

(defun getfilmsg (forknum)
;;; waits for file message to come from fork
     (cddr (waitmsg 'FIL forknum)))  ;return the file message i.e cddr

(defun chkmsg (type fork#)
;;; checks if an incoming message is of the adequate type and comes from
;;; the adequate sender.If so returns a list of the form
;;;		<type job# ! message>
(prog (w)
      a	(setq w (gmsg))		;get a message
	(and  (or (and type (eq type (car w))) T)
	      (or (and fork# (= fork# (cadr w))) T)
	      (return w))    ;message is the right one
	(return nil)))

(defun gimme (l num)
;;; l is a list of atoms in ascii. num is transformed into an interned atom and
;;; nconced at the end of the list. Num is a fixnum equiv. to 5 ascii chars
((lambda (w) (or (and l (nconc l w)) w))
 (list (pnput (list num) t))))
(LAP FORKME SUBR)
(ARGS FORKME (NIL . 3))
;;; this routine creates a new process with name provided in the
;;; form (FOO BAR (BLE TCH)) which should be a dump file to
;;; be started. Usually this sysout should execute a STARTFORK, which when
;;; released will give it the job number of its creator (like a fork handle)
;;; the file name should be preprocessed and translated into 3 args in sixbit
;;; as follows: A = filnam B= ext C=prjprg. Just sprouts the new process
;;; and returns T if successful and NIL if not (ie busy). ALL the args must appear.
;;; The calling routine should provide the corresponding defaults. Device is
;;; always DSK
	(JSP T FXNV1)			;first arg should be integer
	(MOVEM TT (+ FILE 1))		;move filnam (returned in TT
	(JSP T FXNV2)			;so should extension. result in D
					;ext comes in upper part of D
	(ADDI D 4)			;mode bit to start as phantom
	(MOVEM D (+ FILE 2))		;ext + modes
	(JSP T FXNV3)			;ppn in SIXBIT integer?
	(MOVEM R (+ FILE 4))		;ppn to SWAP arg list
	(MOVE TT (% 0 0 FILE))		;[0,,FILE]
	(CALLI TT 400004)		;swap creating process; returns fork# in TT
	(JUMPE TT FOO)			;failure? if so return NIL
	(JRST 0 FIX1)			;job number of new process. FXCONS and POPJ
FOO	(HLLZI A)			;return NIL (error)
	(POPJ P)
FILE	(SIXBIT DSK)
	(BLOCK 5)			;swap file info
FORK 	(BLOCK 1)
(ENTRY MSG SUBR)
(ARGS MSG (NIL . 4))
;;; in A receives fixnum for fork#. In B receives fixnum for operation. This fixnum
;;; is chopped in the lower half (i.e only 3 first chars are considered. Lower
;;; half will hold current job#. The third arg if non-nil will point to a list
;;; of fixnums to assemble as the message. The 4th arg is the originating job#
	(JSP T FXNV1)			;A to number. TT holds fork num in 0,,777777
	(MOVEM TT MSG)			;fork#
	(MOVSI TT -32)			;clear mailbox
	(SETZM 0 LETTER(TT))
	(AOBJN TT,(- * 1))
;;	at this point C holds the list and AR1 the jobnum as a fix#
	(JSP T FXNV2)			;B to number. D holds operation
	(MOVEM D LETTER)		;header is TYPE and JOB#
	(MOVE AR1 0 AR1)		;get job# from fixnum cons cell
	(MOVEM AR1 (+ LETTER 1))	;here is job
	(MOVSI TT -30)			;at most 30 words to transfer
	(MOVE A C)			;save pointer to list. C has pointer
TST	(JUMPE A DONE)			;either done transferring or no message
	(HLRZ C 0 A)			;car
	(JSP T FXNV3)			;check its fixnum
	(MOVEM R (+ LETTER 2)(TT))	;move ascii to message
	(HRRZ A 0 A)			;A← cdr(A)
	(AOBJN TT,TST)
DONE	(MAIL 5 MSG)   			;skpsend
	(JRST 0 BOXFUL)			;mailbox busy
	(JRST 0 OK)	
	(MOVEI A (QUOTE NOJOB))		;no such fork
	(POPJ P)
BOXFUL  (HLLZI A)			;return NIL
	(POPJ P)
OK	(MOVEI A (QUOTE T))		;return T
	(POPJ P)
MSG	(BLOCK 1)			;MSG=fork# MSG+1 points to message
	(0 0 LETTER)
LETTER  (BLOCK 32)
(ENTRY GMSG SUBR)
(ARGS GMSG (NIL . 0))
;;; This function waits for a message from any fork. Message format is
;;;
;;;		-----------------
;;;	MESS    TYPE ascii 1 word
;;;		-----------------
;;;     MESS+1  JOB integer			;originating job#
;;;		-----------------
;;;	MESS+2       ......			;start of message as asciz words
;;;		-----------------
;;; 		     ......
;;;		-----------------
;;;     MESS+30      ......
;;;		-----------------
;;;
;;; It convets the type into an interned atom, converts the job# to fixnum,
;;; generates a list of the message atoms and returns
;;;		<type job# ! message>
    	(MAIL 1 BUFFER)		;WRCV. Wait till message is received
	(MOVE TT BUFFER)	;get message type
	(JSP T FXCONS)		;convert to FIXNUM for GIMME
	(MOVE B A)		;now we do <type>
	(HLLZI A)		;A ← NIL
	(CALL 2 (FUNCTION GIMME)) ; returns <type>
	(PUSH FXP A)		;save result
	(MOVE TT (+ BUFFER 1))	;get job#
	(JSP T FXCONS)		;convert to fixnum
	(HLLZI B)
	(CALL 2 (FUNCTION CONS)) ;returns <job#>
	(MOVE B A)
	(POP FXP A)		;now append to get in A <type job#>
	(CALL 2 (FUNCTION APPEND))

;;;
;;; Now we construct the message if any, and nconc it to the list. Message
;;; starts at BUFFER+2. A holds <type job#>
;;;
     	(MOVSI AR1 -30)		;up to 30 word messages
REPEAT 	(MOVE B (+ BUFFER 2)(AR1)) ;get current element
	(JUMPE B LUSER)		;if zeros then done
	(MOVE TT B)		;get fixnum
	(PUSH FXP A)		;A will be clobbered
	(JSP T FXCONS)		;return FIXNUM
	(MOVE B A)		;B holds fixnum 
	(POP FXP A)		;well, A holds list again
	(PUSH FXP AR1)		;save AR1 (ie count)
	(CALL 2 (FUNCTION GIMME)) ;returns in A append1(A (pnput ..B.. T))
	(POP FXP AR1)
	(AOBJN AR1 REPEAT)	;repeat
LUSER  	(POPJ P)		;return
BUFFER  (BLOCK 32)		;message fooey! kludge so losing lap works

(ENTRY MERGEPPN SUBR)
(ARGS MERGEPPN (NIL . 2))
;;; places p in left and pn in right half
	(MOVE TT 0 A)			;get prj sixbit into TT
	(JSP T NORMAL)			;right justify within halfword
	(PUSH FXP TT)			;save in stack
	(MOVE TT 0 B)			;get pn sixbit
	(JSP T NORMAL)			;same
	(HLRZ TT TT)			;TT has 0,,pn
	(HLL TT 0 FXP)			;TT now has p,,pn
	(MOVE A TT)			;return p,,pn
	(JSP T FXCONS)			;get fixnum
	(POP FXP FXP)
	(POPJ P)
NORMAL	(MOVSI D -3)			;at most 3 sixbit chars
        (TLNE TT 000077)		;last 6 bits are zero?
	(JRST 0 ALL)			;OK tested
	(LSH TT -6)			;shift right 6 bits
	(AOBJN D (- * 3))
ALL	(JRST 0 @ T)			;return
(ENTRY GETMYJOB SUBR)
(ARGS GETMYJOB (NIL . 0))	
;;; returns fixnum with job# of caller. used to pass handles to forks
	(MOVEI TT 226)
	(CALLI TT 33)
	(CALLI TT 33)
	(JRST 0 FIX1)

(ENTRY FORK-SUSPEND SUBR)
(ARGS FORK-SUSPEND (NIL . 0))
	(MOVEM 17 (+ ACS 17))	;Save the accs
	(MOVEI 17 ACS)
	(BLT 17 (+ ACS 16))
;should insert here code to print out suspend message
	(MOVEI TT STRT)
	(MOVEM TT 120)
	(CALLI 1 12)		;Exit 1,
STRT	(MOVEM TT JOB)		;Save master job number
	(HRLZI 17 ACS)		;restore acs
	(BLT 17 17)
	(MOVE TT JOB)
	(JRST 0 FIX1)		;Number cons job number
JOB	(0)
ACS	(BLOCK 20)
NIL